home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / yerk / mps231ss.hqx / Mops source / Module source / Extrasmod.txt < prev    next >
Text File  |  1993-02-23  |  11KB  |  484 lines
  1. \ This module implements a number of words that we need only at compile time,
  2. \ or only in the Mops development environment.
  3.  
  4. \ CASE[ is another keyed CASE.  Each test value or range is compiled into
  5. \ a pair of 2-byte entries in a table.  Compilation is turned off and on
  6. \ while getting the test values, which are evaluated at compile time.
  7. \ This is slightly less flexible than Eaker's CASE, but is faster and more
  8. \ compact.  It is also adequate for the majority of keyed case needs.  When
  9. \ you want a positional case, SELECT{ is still the best.
  10.  
  11.  
  12. false    value    NEED_EXIT?
  13.  
  14. : CASE[    immediate    \ ( -- mark chk cnt )  Implements CASE[ in main dic.
  15.     postpone (case)
  16.     here  0 ,                \ Table offset and end offset will go here
  17.     11 ( chk value )  0  ( Initial case count )
  18.     false -> need_exit?            \ No stub compiled yet
  19.     postpone [  ;
  20.  
  21. : NEW_STUB  { chk cnt lo hi flg -- lo hi here chk cnt+1 }
  22.     chk 11 ?pairs
  23.     lo  hi  here
  24.     need_exit?
  25.     if  \ Compile (exit) for end of previous stub
  26.         postpone (exit)
  27.         2+                \ Adjust addr of new stub
  28.     then
  29.     flg -> need_exit?            \ True if we're starting a stub
  30.     11  cnt 1+
  31.     postpone ]  ;
  32.  
  33. : ]=>        immediate    dup  true new_stub   ;    
  34. : ],        immediate    dup false new_stub   ;    
  35. : RANGE]=>    immediate    true new_stub   ;    
  36. : RANGE],        immediate    false new_stub   ;    
  37.  
  38. : DEFAULT=>   immediate   { chk cnt -- mark chk cnt }
  39.     chk 11 ?pairs  cnt 0= abort" No cases!"
  40.     postpone (exit)
  41.     here 12 cnt  ;        immediate
  42.  
  43. : STUB>TBL  { lo hi mark -- }
  44.     lo w,  hi w,  here mark -  w,  ;
  45.  
  46. : STUBS>TBL    \ ( cnt -- )
  47.     for  stub>tbl  next  ;
  48.  
  49. : ]CASE    immediate   { dflt-mark chk cnt \ tbl-addr case-mrk -- }
  50.     chk 12 ?pairs
  51.     postpone (exit)  ( for default stub )
  52.     here -> tbl-addr
  53.     \ Now we build the table:
  54.     cnt w,
  55.     cnt stubs>tbl
  56.     here  dflt-mark -  w,
  57.     -> case-mrk        \ Addr following (CASE) - left in stk before
  58.     tbl-addr case-mrk -  case-mrk w!
  59.     here case-mrk -  case-mrk 2+ w!  ;
  60.  
  61. \        ======== Code to aid testing =========
  62.  
  63. \ SM and BG set the Mops window small and big respectively.
  64. \ SM is used when we want to split the screen for debugging.
  65. \ It puts the Mops window in the lower half of the screen so the source
  66. \ text window can occupy the top half.  BG puts the Mops window back to
  67. \ where its normal size and position.
  68.  
  69. : SM    494 150 size: fwind  2 190 move: fwind  cls  ;
  70. : BG    494 286 size: fwind  2  40 move: fwind  cls  ;
  71.  
  72.  
  73. \        ======== Display of source code ========
  74.  
  75. false    value    LOG_THERE?
  76. false    value    SRC_THERE?
  77. false    value    USE_MOD?
  78.  
  79.     objPtr    THEMOD  class_is module
  80.  
  81.     window    DW
  82.  
  83.     file    LOG
  84.     file    SRC
  85.  
  86.     string+    DSP
  87.     string+    S
  88.     string+    $TMP
  89.     string+    $LOG
  90.     string+    $PRF
  91.  
  92.     0    value    CURS_POS
  93.     0    value    CURS_ROW
  94.     0    value    CURS_COL
  95.  
  96.     0    value    MK_CFA
  97.     0    value    TOPDIR
  98.     0    value    TOPDATE
  99.  
  100.  
  101. : SET_DSP  { \ cr? -- }
  102.     true -> cr?
  103.     s  copyto: dsp
  104.     curs_pos >pos: dsp
  105.     2 0 DO  <nextline?: dsp  NIF  LEAVE  THEN  LOOP
  106.     pos: dsp
  107.     #lines 0 ?DO
  108.         nextline?: dsp  NIF  false -> cr?  LEAVE  THEN
  109.     LOOP
  110.     >pos: dsp
  111.     cr? more: dsp  ;
  112.  
  113.  
  114. local DISPLAY  { disp? \ redraw? end_disp curs_line_pos 1st? -- }
  115.  
  116. : (DISP)
  117.     0 -> curs_row  0 -> curs_line_pos  true -> 1st?
  118.     disp? IF  4 tFont  9 tSize  -curs  cls  THEN        \ Monaco 9
  119.     BEGIN
  120.         nextline?: dsp  0EXIT
  121.         lim: dsp  end_disp  > ?EXIT
  122.         1st? IF  false -> 1st?  ELSE  disp? IF cr THEN  THEN
  123.         lim: dsp  curs_pos  <
  124.         IF  1 ++> curs_row  lim: dsp 1+  -> curs_line_pos  THEN
  125.         disp? IF  get: dsp  type  THEN
  126.     AGAIN  ;
  127.  
  128. : SHOW_CURS
  129.     +curs  disp? NIF  .cur  THEN        \ If just updating, erase curs
  130.     curs_pos curs_line_pos -  dup -> curs_col 1+  6 *    \ x
  131.     curs_row 1+ #lead *  6 +                \ y
  132.     gotoxy  .cur  ;
  133.  
  134. : (DISPLAY)
  135.     lim: dsp  -> end_disp
  136.     save: dsp  0 >len: dsp
  137.     (disp)
  138.     restore: dsp  ;
  139.  
  140.  
  141. :loc DISPLAY
  142.     set: dw
  143.     (display)
  144.     curs_row 0=  pos: dsp  0<>  and  -> redraw?
  145.     curs_row 6 >  lim: dsp  size: dsp  <  and  --> redraw?
  146.     redraw? IF  set_dsp  update: dw  THEN
  147.     show_curs
  148.     set: fWind  ;loc
  149.  
  150. ' redraw  setdraw: dw        \ Note: this must refer to the EXPORTED
  151.                 \ version of redraw.
  152.  
  153. : REDRAW    true  display  ;
  154. : UPD        false display  ;
  155.  
  156. : 1UP
  157.     curs_pos 1-  0 max  dup >pos: s >lim: s
  158.     <nextline?: s  0EXIT
  159.     pos: s  dup IF  1+  THEN  -> curs_pos  upd  ;
  160.  
  161. : 1DN
  162.     curs_pos dup >pos: s >lim: s
  163.     nextline?: s  0EXIT
  164.     lim: s 1+  -> curs_pos  upd  ;
  165.  
  166. : 1LFT    ;    \ Really not much point in implementing these!
  167. : 1RT   ;
  168.  
  169. : HOME        0    -> curs_pos  upd  ;
  170. : END        size: s    -> curs_pos  upd  ;
  171.  
  172. : DEFNUP  { \ pos -- }
  173.     curs_pos 1-  0 max  dup  >pos: s  >lim: s
  174.     BEGIN
  175.         <nextline?: s  0EXIT
  176.         pos: s  -> pos  pos IF  1 ++> pos  THEN
  177.         ptr: s  pos +  c@  & :  =
  178.         IF  pos -> curs_pos  upd  EXIT  THEN
  179.     AGAIN  ;
  180.  
  181. : DEFNDN
  182.     curs_pos  dup  >pos: s  >lim: s
  183.     BEGIN
  184.         nextline?: s  0EXIT
  185.         ^1st: s  1+  c@  & :  =
  186.         IF  pos: s  1+  -> curs_pos  upd  EXIT  THEN
  187.     AGAIN  ;
  188.  
  189.  
  190. : ADDR>CURS  { addr \ offs -- curs-pos }    \ Exported.
  191.     log_there?  NIF  0  EXIT  THEN
  192.     addr filestart_dp -  -> addr   0 -> offs
  193.     reset: $log
  194.     BEGIN
  195.         len: $log  0<=  IF  0  EXIT  THEN
  196.         ^1st: $log  w@  addr >
  197.         IF  ( found )
  198.             offs -> curs_pos  upd   offs  EXIT
  199.         THEN
  200.         ^1st: $log  2+  @  -> offs
  201.         6 skip: $log
  202.     AGAIN  ;
  203.  
  204.  
  205. : SELECTDW            \ Exported.
  206.     src_there?  0EXIT
  207.     select: dw  ;
  208.  
  209.  
  210. : OPEN_SRC_WINDOW
  211.     sm
  212.     new: s  s copyto: dsp  new: $tmp
  213.     2 38  494 170  put: tempRect
  214.     tempRect  " "
  215.     docWind  true true  new: dw
  216. \    10 10 500 300 true setDrag: dw
  217.     screenbits true setGrow: dw
  218.     select: fWind  set: fWind
  219.     true -> src_there?  ;
  220.  
  221. : CHK_DATE
  222.     getFileInfo: src  OK?  src 76 + @
  223.     use_mod?
  224.     IF
  225.         base: theMod  @
  226.     ELSE
  227.         mk_cfa 6 + @  ?dup NIF -1 THEN
  228.     THEN
  229.     u>
  230.     IF
  231.         3 beep  cr  msg# 76    \ "Source later than compiled version"
  232.     THEN  ;
  233.  
  234.     
  235. : (OPEN_SRC)
  236.     2dup  put: $tmp  2dup  name: src  title: dw
  237.     use_mod?
  238.     NIF
  239.         mk_cfa @  setDirID: src
  240.     THEN
  241.     openReadOnly: src  ?EXIT      \ Out on error
  242.     chk_date
  243.     src  readAll: s  close: src  drop
  244.     0 -> curs_pos  set_dsp  update: dw  ;
  245.  
  246.  
  247. : SRC_NAME
  248.     mk_cfa >name n>count 1-  ;
  249.  
  250. : OPEN_SRC
  251.     src_name  (open_src)  ;
  252.  
  253. : OPEN_SRC_IN_MOD
  254.     txtName: theMod  (open_src)  ;
  255.  
  256.  
  257. : (CREATE_LOG)
  258.     here -> filestart_dp
  259.     new: $lg1  new: $lg2
  260.     $ B3010000 pad !    \ Unique marker for log files | version
  261.     false -> relocChk?
  262.     here pad 4+ reloc!
  263.     true -> relocChk?
  264.     pad 8  put: $lg1  ;
  265.  
  266.  
  267. : (WRITE_LOG)        \ Called to write out the log and profile strings to the
  268.             \  2 corresponding files
  269.     getname: topfile  put: $tmp
  270.     " .log"  add: $tmp
  271.     all: $tmp  name: log
  272.     use_mod?  IF  0  ELSE  topDir  THEN
  273.     setDirID: log
  274.         \ OK to use zero for modules, since the module's source
  275.         \ file name will be fully qualified.
  276.     create: log  ?dup
  277.     IF  . space ." I/O err creating log file " abort  THEN
  278.     0 setDirID: log
  279.     'type SLOG  'type MOPS  set: log
  280.     reset: $lg1  len: $lg1  ^1st: $lg1 2+  w!
  281.     all: $lg1  write: log  OK?  all: $lg2  write: log  OK?
  282.     close: log  OK?
  283.     release: $lg1  release: $lg2  ;
  284.  
  285.  
  286. : OPEN_LOG
  287.     false -> log_there?
  288.     clear: $log  clear: $prf
  289.     use_mod?
  290.     IF
  291.         " .txt.log" extname: theMod  put: $tmp
  292.         all: $tmp  name: log
  293. \        base: theMod 4+ @  setDirID: log
  294.     ELSE
  295.         mk_cfa 4+  w@
  296.         NIF  ( No log file )
  297.             clear: $log  EXIT
  298.         THEN
  299.         " .log" add: $tmp
  300.         all: $tmp  name: log  0 setVref: log
  301.         mk_cfa @  setDirID: log
  302.     THEN
  303.     openReadOnly: log  ?EXIT        \ If error, maybe log not there.
  304.     pad 8 read: log  OK?
  305.     pad w@  $ B301 =  0EXIT        \ Out if not valid log file
  306.     true -> log_there?
  307.     use_mod?
  308.     IF
  309.         base: theMod
  310.         #imp: theMod  2* +  8 +
  311.     ELSE
  312.         pad 4+ @abs
  313.     THEN
  314.     -> filestart_dp
  315.     log  pad 2+ w@ 8 -  readN: $log
  316.     log  readRest: $prf  close: log  drop
  317. \    rd: $log  rd: $prf
  318. \    set: fwind  dump: $log  set: dw        \ debugging only
  319.     src_there? IF  redraw  THEN
  320.     true -> log_there?  ;
  321.  
  322.  
  323. : CL        \ Close src and log etc.
  324.     src_there?  0EXIT
  325.     close: dw  release: s  release: $tmp  release: $log  release: $prf
  326.     close: src drop
  327.     false -> log_there?  false -> src_there?
  328.     drop: extrasmod  ;
  329.  
  330.  
  331. : (FINDMK)    \ ( cfa 0 -- )
  332.     drop  dup -> mk_cfa  2- w@x file-mark = -> endTrav?  ;
  333.     
  334. : FIND_MARK?    \ ( start-addr -- )
  335.     ['] (findmk)  0  rot  trav-from
  336.     endTrav?  ;
  337.  
  338.  
  339. : LOCATE_SRC    \ ( cfa -- )  Exported.  Opens source window for given
  340.         \ definition, if possible.
  341.     lock: extrasmod        \ Since we have a window, and windows
  342.                 \ mustn't move!
  343.     use_mod?
  344.     NIF
  345.         find_mark?
  346.         NIF
  347.             src_there?  IF  cl  THEN  EXIT
  348.         THEN
  349.     ELSE
  350.         drop
  351.     THEN
  352.     src_there?
  353.     NIF  open_src_window  THEN
  354.     use_mod?
  355.     IF
  356.         open_src_in_mod  open_log
  357.         false -> use_mod?    \ For next time
  358.     ELSE
  359.         open_src  open_log
  360.     THEN  ;
  361.  
  362.  
  363. : USE_MODULE    \ ( ^mod -- )
  364.     -> theMod  true -> use_mod?  ;
  365.  
  366. : PROF_STR    \ Exported - called by DebugMod to get hold of the profile
  367.         \  string and source string.
  368.     reset: $prf  reset: s
  369.     $prf  s  ;
  370.  
  371.  
  372. \    ======== Code for loading and reloading =========
  373.  
  374. : PURGE_INIT_ACTIONS  { \ index -- }
  375.             \ We call this before reloading, to get rid of any
  376.             \ invalid entries out of INIT_ACTIONS.
  377.     0 -> index
  378.     BEGIN
  379.         index  size: init_actions  >=  ?EXIT
  380.         index  ^elem: init_actions  @abs  here u>
  381.         IF    index  remove: init_actions
  382.         ELSE    1 ++> index
  383.         THEN
  384.     AGAIN  ;
  385.  
  386.  
  387. : <CS  { addr len c \ offs -- addr len offs }
  388.     len -> offs
  389.     addr  addr len + 1-  DO
  390.         i c@  c = IF  LEAVE  THEN
  391.         -1 ++> offs
  392.     -1 +LOOP
  393.     addr len offs  ;
  394.  
  395.  
  396. : +LOG        true  -> log?  ;
  397. : -LOG        false -> log?  ;
  398.  
  399.  
  400. : SAVE-LOAD
  401.     getName: topFile  put: $tmp  bl +: $tmp  reset: $tmp
  402.     & :  <chsearch: $tmp  negate skip: $tmp
  403.     get: $tmp  sHdr  file-mark w,
  404.     topDir ,  log? w,  topDate ,
  405.     release: $tmp  ;
  406.  
  407.  
  408. : LOADIT  { \ svCurs -- }
  409.     watchcurs  purge_init_actions
  410.     curs -> svCurs -curs
  411.     getFileInfo: topFile  NIF  topFile 76 + @  ELSE  0  THEN  -> topDate
  412.     clear: topFile
  413.     topDir  setDirID: topFile
  414.     save-load
  415.     MBcomp LdFromMod  drop: loadFile
  416. \    log?  IF  -log  THEN
  417.     svCurs -> curs
  418.     arrowcurs  ;
  419.  
  420.  
  421. : L         \ Load
  422.     pushNew: loadfile
  423.     'type TEXT 1 stdget: topfile
  424.     IF
  425.         getDirID  dup  setDirID: topFile  -> topDir
  426.         loadit
  427.     ELSE
  428.         clear: loadfile
  429.     THEN  ;  
  430.  
  431. : FM        \ Forget to mark
  432.     here find_mark?  not abort" No mark!"
  433.     mk_cfa >link (forget)  ;
  434.  
  435. : RL
  436.     here find_mark?  not abort" L not done!"
  437.     cl        \ Close source window if open as it probably
  438.             \ won't be valid any more.
  439.     pushnew: loadfile
  440.     src_name  name: topFile
  441.     mk_cfa @  dup  -> topDir  setDirID: topFile
  442. \    mk_cfa 4+ w@x  ++> log?
  443.     mk_cfa >link (forget)  loadit  ;
  444.  
  445.  
  446.  
  447. \ Put NEED XXX at the start of a file that requires XXX to be already
  448. \ loaded.  If the word XXX is not defined, a file of that name is loaded.
  449. \ Note that only one blank or tab is allowed between NEED and the ilename.
  450. \ This is because we use WORD" to read the ilename, so that names with
  451. \ embedded blanks are allowed.
  452.  
  453. : NEED  { \ svLog svTopDir svTopDate -- }
  454.     word"  count                \ Get name from input
  455.     put: $tmp  bl +: $tmp  reset: $tmp
  456.     & :  <chsearch: $tmp  negate skip: $tmp
  457.     get: $tmp  sFind  nip
  458.     IF  release: $tmp  EXIT  THEN    \ Found - nothing else to do
  459.                         \ Not found - load it
  460.     latest name> 2- w@x  file-mark =
  461.     IF                \ That was a file-mark - forget it so RL
  462.                     \  won't make us reload NEEDed files
  463.         latest n>link (forget)
  464.     THEN
  465.     pushnew: loadFile  get: $tmp  1-  name: topfile
  466.     release: $tmp
  467.     log? -> svLog
  468.     -log                    \ Don't log NEEDed file
  469.     openReadOnly: topFile  OK?
  470.     close: topFile  drop
  471.     getFileInfo: topFile  OK?
  472.     topDate -> svTopDate
  473.     topDir -> svTopDir
  474. \    getDirID: topFile  -> topDir      \ I'm not too sure why this doesn't work
  475.     0 -> topDir
  476.     clear: topFile                \ Leaves name field intact
  477.     loadit                    \ Load NEEDed file
  478.     svLog IF  +log  THEN
  479.     svTopDate -> topDate
  480.     svTopDir  -> topDir
  481.     save-load  ;
  482.  
  483. ' cl  setrelease
  484.